home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / bgsound6.zip / BGSOUND.PAS < prev    next >
Pascal/Delphi Source File  |  1991-01-30  |  8KB  |  256 lines
  1. UNIT BGSOUND;
  2.  
  3. {$S-,R-,F+}
  4.  
  5. {
  6.  UNIT BGSOUND;
  7.   Version for Turbo Pascal 6.0 by Francesco Duranti (30 january 1991)
  8.   From BGSOUND adapted for TP5.5 by Francesco Duranti (9 january 1991)
  9.   
  10.  From :
  11.   BGSND.INC
  12.  
  13.   Background Sound for Turbo Pascal
  14.   Michael Quinlan
  15.   9/17/85
  16.  
  17.   The routines are rather primitive, but could easily be extended.
  18.  
  19.   The sample routines at the end implement something similar to the
  20.   BASIC PLAY statement.
  21.  
  22. }
  23.  
  24. INTERFACE
  25.  
  26. uses crt,dos;
  27.  
  28. type BGSItem   = record
  29.                    cnt  : integer;  { count to load into the 8253-5 timer;
  30.                                       count = 1,193,180 / frequency }
  31.                    tics : integer   { timer tics to maintain the sound;
  32.                                       18.2 tics per second }
  33.                  end;
  34.  
  35.      _BGSItemP = ^BGSItem;
  36.  
  37.  
  38. const BGSPlaying : boolean = FALSE;  { TRUE while music is playing }
  39.  
  40. procedure BGSPlay(n : integer; var items);
  41. { You call this procedure to play music in the background. You pass the number
  42.   of sound segments, and an array with an element for each sound segment. The
  43.   array elements are two words each; the first word has the count to be loaded
  44.   into the timer (1,193,180 / frequency). The second word has the duration of
  45.   the sound segment, in timer tics (18.2 tics per second). }
  46.  
  47. procedure PlayMusic(s : string);
  48. { Accept a string similar to the BASIC PLAY statement. The following are
  49.   allowed:
  50.     A to G with optional #
  51.       Plays the indicated note in the current octave. A # following the letter
  52.       indicates sharp. A number following the letter indicates the length of
  53.       the note a quarter note, 16 = sixteenth note, 1 = whole note, etc.).
  54.     On
  55.       Sets the octave to "n". There are 7 octaves, numbered 0 to 6. Each octave
  56.  
  57.       goes from C to B. Octave 3 starts with middle C.
  58.     Ln
  59.       Sets the default length of following notes. L1 = whole notes, L2 = half
  60.       notes, etc. The length can be overridden for a specific note by follow-
  61.       ing the note letter with a number.
  62.     Pn
  63.       Pause. n specifies the length of the pause, just like a note.
  64.     Tn
  65.       Tempo. Number of quarter notes per minute. Default is 120.
  66.  
  67.   Spaces are allowed between items, but not within items. }
  68.  
  69. IMPLEMENTATION
  70.  
  71. var _BGSNextItem : _BGSItemP;
  72.     _BGSNumItems : integer;
  73.     _BGSOldInt1C : procedure;
  74.     _BGSDuration : integer;
  75.     MusicArea : array[1..100] of BGSItem; { contains sound segments }
  76.  
  77. { frequency table from Peter Norton's Programmer's Guide to the IBM PC, p. 147 }
  78. const Frequency : array[0..83] of real =
  79.   {    C        C#       D        D#       E        F        F#       G        G#       A        A#       B }
  80.     (32.70,   34.65,   36.71,   38.89,   41.20,   43.65,   46.25,   49.00,   51.91,   55.00,   58.27,   61.74,
  81.      65.41,   69.30,   73.42,   77.78,   82.41,   87.31,   92.50,   98.00,  103.83,  110.00,  116.54,  123.47,
  82.     130.81,  138.59,  146.83,  155.56,  164.81,  174.61,  185.00,  196.00,  207.65,  220.00,  233.08,  246.94,
  83.     261.63,  277.18,  293.66,  311.13,  329.63,  349.23,  369.99,  392.00,  415.30,  440.00,  466.16,  493.88,
  84.     523.25,  554.37,  587.33,  622.25,  659.26,  698.46,  739.99,  783.99,  830.61,  880.00,  932.33,  987.77,
  85.    1046.50, 1108.73, 1174.66, 1244.51, 1378.51, 1396.91, 1479.98, 1567.98, 1661.22, 1760.00, 1864.66, 1975.53,
  86.    2093.00, 2217.46, 2349.32, 2489.02, 2637.02, 2793.83, 2959.96, 3135.96, 3322.44, 3520.00, 3729.31, 3951.07);
  87.  
  88. procedure _BGSPlayNextItem;
  89. { used internally to begin playing the next sound segment }
  90.   begin
  91.     _BGSNumItems := _BGSNumItems - 1;
  92.     Port[$43] := $B6;
  93.     with _BGSNextItem^ do begin
  94.       Port[$42] := Lo(cnt);
  95.       Port[$42] := Hi(cnt);
  96.       _BGSDuration := tics;
  97.       if cnt <> 0 then Port[$61] := Port[$61] or $03
  98.     end;
  99.     _BGSNextItem := Ptr(Seg(_BGSNextItem^), Ofs(_BGSNextItem^) + SizeOf(BGSItem))
  100.   end;
  101.  
  102. procedure _BGSInt1C;interrupt;
  103. { Interrupt procedure invoked 18.2 times a second. Decrements a count and
  104.   when the count equals zero, selects the next sound segment to play. }
  105.  
  106.   begin
  107.     asm
  108.       pushf
  109.       cli
  110.     end;
  111.     _BGSOldInt1C;
  112.     _BGSDuration := _BGSDuration - 1;
  113.     if _BGSDuration = 0 then begin
  114.       Port[$61] := Port[$61] and $F8;
  115.       if _BGSNumItems = 0 then begin
  116.         SetIntvec($1C, addr(_BGSOldInt1C));
  117.         BGSPlaying := FALSE
  118.       end else begin
  119.         _BGSPlayNextItem
  120.       end
  121.     end;
  122.     asm
  123.       sti
  124.     end;
  125.   end;
  126.  
  127. procedure BGSPlay(n : integer; var items);
  128.  
  129.   var item_list : array[0..1000] of BGSItem absolute items;
  130.   begin
  131.  
  132.     while BGSPlaying do  { wait for previous sounds to finish }
  133.       ;
  134.  
  135.     if n > 0 then begin
  136.       _BGSNumItems := n;
  137.       _BGSNextItem := Addr(item_list[0]);
  138.       BGSPlaying   := TRUE;
  139.       _BGSPlayNextItem;
  140.       GetIntvec($1C,addr(_BGSOldInt1C));
  141.       SetIntvec($1C,addr(_BGSInt1C))
  142.     end
  143.   end;
  144.  
  145. procedure PlayMusic(s : string);
  146.   var i, n : integer;  { i is the offset in the parameter string;
  147.                          n is the element number in MusicArea }
  148.       cchar : char;
  149.  
  150.   var NoteLength    : integer;
  151.       Tempo         : integer;
  152.       CurrentOctave : integer;
  153.  
  154.   function GetNumber : integer;
  155.   { get a number from the parameter string }
  156.   { increments i past the end of the number }
  157.     var n : integer;
  158.     begin
  159.       n := 0;
  160.       while (i <= length(s)) and (s[i] in ['0'..'9']) do begin
  161.         n := n * 10 + (Ord(s[i]) - Ord('0'));
  162.         i := i + 1
  163.       end;
  164.       GetNumber := n
  165.     end;
  166.  
  167.   procedure GetNote;
  168.   { input is a note letter. convert it to two sound segments --
  169.     one for the sound then a pause following the sound. }
  170.   { increments i past the current item }
  171.     var note : integer;
  172.         len  : integer;
  173.         l    : real;
  174.  
  175.     function CheckSharp(n : integer) : integer;
  176.     { check for a sharp following the letter. increments i if one found }
  177.       begin
  178.         if (i < length(s)) and (s[i] = '#') then begin
  179.           i := i + 1;
  180.           CheckSharp := n + 1
  181.         end else
  182.           CheckSharp := n
  183.       end;  { CheckSharp }
  184.  
  185.     function FreqToCount(f : real) : integer;
  186.     { convert a frequency to a timer count }
  187.       begin
  188.         FreqToCount := Round(1193180.0 / f)
  189.       end;  { FreqToCount }
  190.  
  191.     begin  { GetNote }
  192.       case cchar of
  193.         'A' : note := CheckSharp(9);
  194.         'B' : note := 11;
  195.         'C' : note := CheckSharp(0);
  196.         'D' : note := CheckSharp(2);
  197.         'E' : note := 4;
  198.         'F' : note := CheckSharp(5);
  199.         'G' : note := CheckSharp(7)
  200.       end;
  201.       MusicArea[n].cnt := FreqToCount(Frequency[(CurrentOctave * 12) + note]);
  202.       if (s[i] in ['0'..'9']) and (i <= length(s)) then
  203.         len := GetNumber
  204.       else
  205.         len := NoteLength;
  206.       l := 18.2 * 60.0 * 4.0 / (Tempo * len);
  207.       MusicArea[n].tics := Round(7.0 * l / 8.0);
  208.       if MusicArea[n].tics = 0 then MusicArea[n].tics := 1;
  209.       n := n + 1;
  210.       MusicArea[n].cnt := 0;
  211.       MusicArea[n].tics := Round(l / 8.0);
  212.       if MusicArea[n].tics = 0 then MusicArea[n].tics := 1;
  213.       n := n + 1
  214.     end;  { GetNote }
  215.  
  216.   procedure GetPause;
  217.   { input is a pause. convert it to a silent sound segment. }
  218.   { increments i past the current item }
  219.     var len  : integer;
  220.         l    : real;
  221.  
  222.     begin  { GetPause }
  223.       MusicArea[n].cnt := 0;
  224.       if (s[i] in ['0'..'9']) and (i <= length(s)) then
  225.         len := GetNumber
  226.       else
  227.         len := NoteLength;
  228.       l := 18.2 * 60.0 * 4.0 / (Tempo * len);
  229.       MusicArea[n].tics := Round(l);
  230.       if MusicArea[n].tics = 0 then MusicArea[n].tics := 1;
  231.       n := n + 1;
  232.     end;  { GetPause }
  233.  
  234.   begin
  235.     NoteLength := 4;
  236.     Tempo := 120;
  237.     CurrentOctave := 3;
  238.  
  239.     n := 1;
  240.     i := 1;
  241.     while i <= length(s) do begin
  242.       cchar := s[i];
  243.       i := i + 1;
  244.       case cchar of
  245.         'A'..'G' : GetNote;
  246.         'O'      : CurrentOctave := GetNumber;
  247.         'L'      : NoteLength    := GetNumber;
  248.         'P'      : GetPause;
  249.         'T'      : Tempo         := Getnumber
  250.       end
  251.     end;
  252.     BGSPlay(n-1, MusicArea)
  253.   end;
  254.  
  255. end.
  256.